{-# LANGUAGE TypeFamilies #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | Execution mode for tx creation tests.

module Test.Pos.Client.Txp.Mode
       ( TxpTestProperty
       , TxpTestMode
       , withBVData
       ) where

import           Universum

import qualified Data.ByteString as BS
import           Test.QuickCheck (Testable (..), ioProperty)
import           Test.QuickCheck.Monadic (PropertyM, monadic)

import           Pos.Chain.Update (BlockVersionData)
import           Pos.Client.Txp.Addresses (MonadAddresses (..))
import           Pos.Core (Address, makePubKeyAddressBoot)
import           Pos.Core.NetworkMagic (NetworkMagic (..))
import           Pos.Crypto (deterministicKeyGen)
import           Pos.DB (MonadGState (..))

import           Test.Pos.Chain.Genesis.Dummy (dummyBlockVersionData)

----------------------------------------------------------------------------
-- Mock for TxCreateMode
----------------------------------------------------------------------------

type TxpTestMode = ReaderT BlockVersionData IO

----------------------------------------------------------------------------
-- Boilerplate TxpTestMode instances
----------------------------------------------------------------------------

instance MonadGState TxpTestMode where
    gsAdoptedBVData = ask

instance MonadAddresses TxpTestMode where
    type AddrData TxpTestMode = ()
    getNewAddress nm _ _ = pure (fakeAddressForMonadAddresses nm)
    getFakeChangeAddress nm _ = pure (fakeAddressForMonadAddresses nm)

fakeAddressForMonadAddresses :: NetworkMagic -> Address
fakeAddressForMonadAddresses nm = address
  where
    -- seed for address generation is a ByteString with 32 255's
    seedSize = 32
    seed = BS.replicate seedSize (255 :: Word8)
    address = makePubKeyAddressBoot nm $ fst $ deterministicKeyGen seed

withBVData
  :: MonadReader BlockVersionData m
  => BlockVersionData
  -> m a
  -> m a
withBVData bvd = local (const bvd)

----------------------------------------------------------------------------
-- Property
----------------------------------------------------------------------------

type TxpTestProperty = PropertyM TxpTestMode

-- Cannot write a general OVERLAPPABLE instance with MonadTrans since
-- type families cannot be OVERLAPPABLE.
instance MonadAddresses TxpTestProperty where
    type AddrData TxpTestProperty = AddrData TxpTestMode
    getNewAddress nm epochSlots = lift . (getNewAddress nm epochSlots)
    getFakeChangeAddress nm = lift . (getFakeChangeAddress nm)

instance Testable a => Testable (TxpTestProperty a) where
    property = monadic (ioProperty . flip runReaderT dummyBlockVersionData)
